home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / tek41.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  148 lines
  1. ;"tek41.scm", Tektronix 4100 series graphics support in Scheme.
  2. ;Copyright (C) 1992, 1994 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;THIS FILE NEEDS MORE WORK.  Let me know if you test or fix it.
  21.  
  22. ;The graphics control codes are sent over the current-output-port and
  23. ;can be mixed with regular text and ANSI or other terminal control
  24. ;sequences.
  25.  
  26. (define esc-string (string (integer->char #o33)))
  27.  
  28. (define tek41:init
  29.   (string-append
  30.    esc-string "%!0"
  31.    ;;1. set tek mode
  32.    esc-string "MN0"
  33.    ;;2. set character path to 0 (characters placed equal to rotation)
  34.    esc-string "MCB7C;"
  35.    ;;3. set character size to 59 height
  36.    esc-string "MQ1"
  37.    ;;4. set character precision to string
  38.    esc-string "MT1"
  39.    ;;5. set character text index to 1
  40.    esc-string "MG1"
  41.    ;;6. set character write mode to overstrike
  42.    esc-string "RK!"
  43.    ;;7. clear the view
  44.    esc-string "SK!"
  45.    ;;8. clear the segments
  46.    esc-string "LZ"
  47.    ;;9. clear the dialog buffer
  48.    esc-string "%!1"
  49.    ;;10. set ansi mode
  50.    ))
  51.  
  52. (define (tek41:init) (display tek41:init-str) (force-output))
  53.  
  54. (define (tek41:reset)
  55.   (string-append
  56.    esc-string "%!0"
  57.    ;;1. set tek mode
  58.    esc-string "LZ"
  59.    ;;2. clear the dialog buffer
  60.    esc-string "%!1"
  61.    ;;3. set ansi mode
  62.    ))
  63.  
  64. (define (tek41:reset) (display tek41:reset-str) (force-output))
  65.  
  66. (define tek41:graphics-str
  67.   (string-append
  68.    esc-string  "%!0"
  69.    ;;1. set tek mode
  70.    esc-string  (string (integer->char #o14))
  71.    ;;2. clear the screen
  72.    esc-string  "LV0"
  73.    ;;3. set dialog area invisible
  74.    ))
  75.  
  76. (define (tek41:graphics) (display tek41:graphics-str) (force-output))
  77.  
  78. (define tek41:text-str
  79.   (string-append
  80.   esc-string  "LV1"
  81.   ;;1. set dialog area visible
  82.   esc-string  "%!1"
  83.   ;;2. set ansi mode
  84.   ))
  85.  
  86. (define (tek41:text) (display tek41:text-str) (force-output))
  87.  
  88. (define tek41:move-str
  89.   (string-append esc-string  "LF"))
  90.  
  91. (define (tek41:move x y)
  92.   (display tek41:move-str)
  93.   (tek41:encode-x-y x y)
  94.   (force-output))
  95.  
  96. (define tek41:draw-str
  97.   (string-append esc-string  "LG"))
  98.  
  99. (define (tek41:draw x y)
  100.   (display tek41:draw-str)
  101.   (tek41:encode-x-y x y)
  102.   (force-output))
  103.  
  104. (define tek41:set-marker-str (string-append esc-string "MM"))
  105. (define tek41:draw-marker-str (string-append esc-string "LH"))
  106.  
  107. (define (tek41:point x y number)
  108.   (display tek41:set-marker-str)
  109.   (tek41:encode-int (remainder (max number 0) 11))
  110.   (display tek41:draw-marker-str)
  111.   (tek41:encode-x-y x y)
  112.   (force-output))
  113.  
  114. (define (tek41:encode-x-y x y)
  115.   (let ((hix (+ (quotient x 128) 32))
  116.     (lox (+ (modulo (quotient x 4) 32) 64))
  117.     (hiy (+ (quotient y 128) 32))
  118.     (loy (+ (modulo (quotient y 4) 32) 96))
  119.     (eb (+ (* (modulo y 4) 4) (modulo x 4) 96)))
  120.     (if (positive? hiy) (write-char (integer->char hiy)))
  121.     (if (positive? eb) (write-char (integer->char eb)))
  122.     (if (positive? (+ loy eb hix)) (write-char (integer->char loy)))
  123.     (if (positive? hix) (write-char (integer->char hix)))
  124.     (write-char (integer->char lox))))
  125.  
  126. (define (tek41:encode-int number)
  127.   (let* ((mag (abs number))
  128.      (hi1 (+ (quotient mag 1024) 64))
  129.      (hi2 (+ (modulo (quotient mag 16) 64) 64))
  130.      (lo (+ (modulo mag 16) 32)))
  131.     (if (>= number 0) (set! lo (+ lo 16)))
  132.     (if (not (= hi1 64)) (write-char (integer->char hi1)))
  133.     (if (or (not (= hi2 64))
  134.         (not (= hi1 64)))
  135.     (write-char (integer->char hi2)))
  136.     (write-char (integer->char lo))))
  137.  
  138. (define (test)
  139.   (tek41:init)
  140.   (tek41:reset)
  141.   (tek41:graphics)
  142.   (do ((i 0 (+ 1 i)))
  143.       ((> i 15))
  144.     (tek41:linetype i)
  145.     (tek41:move (+ (* 200 i) 1000) 1000)
  146.     (tek41:draw (+ (* 200 i) 2000) 2000))
  147.   (tek41:text))
  148.